-- | Main.hs
-- Main program module.

{-
matsuri - haskell ncurses xmpp client
Copyright (C) 2009 anonymous <newanon@yandex.ru>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

import Config
import UI
import Buffers
import Jabber

import Network
import Graphics.Vty
import Control.Concurrent
import Control.Monad
import Control.Monad.Error

import qualified Data.HashTable as H
import Data.IORef

import Data.List
import Data.Maybe
import Data.Either
import Data.Word
import Data.Char
import System.Directory

word2int :: Word -> Int
word2int x = (fromIntegral x)::Int

-- | Read configs and start main loop.
main = withSocketsDo $ do

    -- read config
    home <- getHomeDirectory
    (config, accounts) <- readConfig $ home ++ "/.matsuri/config.ini"
    configList <- H.toList config
    help <- newIORef []
    buffersList <- getFilteredBuffersList accounts help configList

    vty <- mkVty
    DisplayRegion wx wy <- display_bounds $ terminal vty
    sx <- return $ word2int wx
    sy <- return $ word2int wy
    forkIO $ loopGetEvent vty
    rerender vty sx sy
             config configList accounts buffersList
             0 "" (StatusInfo "") help
    
    -- disconnect all accounts
    H.toList accounts >>= mapM_ accDisconnect

    shutdown vty
  where
    loopGetEvent vty = do
      event <- next_event vty
      putMVar updateEvent (VtyEvent event)
      loopGetEvent vty

-- | Get event and process it.
mainLoop vty sx sy
         config configList accounts buffersList
         curBuf cmd status help =
  do
    event <- takeMVar updateEvent
    case event of
      XMPPEvent changeStatus result ->
        processStatusResult changeStatus cmd result

      VtyEvent event' -> case event' of
        EvResize sx' sy' ->
            rerender vty sx' sy'
                     config configList accounts buffersList
                     curBuf cmd status help
        EvKey (KASCII 'q') [MCtrl] -> return () -- exit
        EvKey KEnter       [] | null cmd -> moveToAlert -- activate next alert
        EvKey (KASCII 'n') [MCtrl] -> moveElem 1 -- down
        EvKey (KDown     ) [] -> moveElem 1 -- down
        EvKey (KPageDown     ) [] -> moveElem (sy - 2) -- down
        EvKey (KASCII 'p') [MCtrl] -> moveElem (-1) -- up
        EvKey (KUp       ) [] -> moveElem (-1) -- up
        EvKey (KPageUp     ) [] -> moveElem (-sy + 2) -- up
        EvKey (KASCII 'o') [MCtrl] -> toggleOffline  -- toggle offline users show
        EvKey (KASCII char) [] ->
            let newCmd = cmd ++ [char]
            in rerender vty sx sy
                        config configList accounts buffersList
                        curBuf newCmd status help
        EvKey KBS [] | not $ null cmd ->
            let newCmd = init cmd
            in rerender vty sx sy
                        config configList accounts buffersList
                        curBuf newCmd status help
        EvKey KEnter [] | not $ null cmd -> do
            parseCmdline config accounts cBuf cmd help >>=
              processStatusResult True ""
        _ -> mainLoop vty sx sy
                      config configList accounts buffersList
                      curBuf cmd status help
    where
      cBuf = buffersList!!curBuf

      findCurBuf buffersList' =
        maybe 0 id (findIndex (==cBuf) buffersList')

      moveElem offset = 
	  	do
			let 
				buf = curBuf + offset
				newBuf | buf < 0 = 0
				       | buf > (length buffersList - 1) = length buffersList - 1
				       | otherwise = buf
			rerender vty sx sy
				config configList accounts buffersList
				newBuf cmd status help

      moveToAlert = 
       do
	   	let newBuf = maybe curBuf id (findIndex isAlert buffersList)
		rerender vty sx sy
			config configList accounts buffersList
			newBuf cmd status help


      toggleOffline = do
		case isShowOffline configList of
			True -> updateConfigValue config "show_offline" "no"
			False -> updateConfigValue config "show_offline" "yes"
		configList'' <- H.toList config
		buffersList'' <- getFilteredBuffersList accounts help configList''
		let curBuf'' = findCurBuf buffersList''
		rerender vty sx sy
			config configList'' accounts buffersList''
			curBuf'' cmd status help

      processStatusResult changeStatus cmd result =
        case result of
          StatusResult (Left err) ->
            rerender vty sx sy
                     config configList accounts buffersList
                     curBuf cmd (StatusError err) help
          StatusResult (Right (_, info)) -> do
            let status' = if changeStatus
                          then (StatusInfo info)
                          else status
            configList' <- H.toList config
            buffersList' <- getFilteredBuffersList accounts help configList'
            let curBuf' = findCurBuf buffersList'
            rerender vty sx sy
                     config configList' accounts buffersList'
                     curBuf' cmd status' help

isAlert :: (BufferElement a) => a -> Bool
isAlert buffer' = (AlertNone /= (getBufferAlert buffer'))

clearIfAlert buffersList newBuf = 
	case buffersList !! newBuf of
		(BufferRosterItem (BufferAccount _ account) name ri) -> do
			case itemAlert ri of
				AlertNone -> return False
				_ -> do
					liftIO $ H.update (users account) name
						(UserRosterItem ri{itemAlert = AlertNone})
					return True
		(BufferGroupchat (BufferAccount _ account) name gc) -> do
			case groupchatAlert gc of
				AlertNone -> return False
				_ -> do
					liftIO $ H.update (users account) name
						(UserGroupchat gc{groupchatAlert = AlertNone})
					return True
		_ -> return False


rerender vty sx sy
         config configList accounts buffersList
         curBuf cmd status help =
  do
    flag <- clearIfAlert buffersList curBuf
    buffersList' <- if flag
                    then getFilteredBuffersList accounts help configList
                    else return buffersList
    renderScreen vty sx sy configList buffersList' curBuf cmd status
    mainLoop vty sx sy
             config configList accounts buffersList'
             curBuf cmd status help

updateConfigValue config name value =
    getHashValue config name >>=?
    putConfigValue config value

-- | Parse command line.
parseCmdline config accounts cBuf cmd help =
    case cmd of
      ('/':cmd') ->
        let words' = words cmd'
        in if not $ null words'
           then parseCommand config accounts cBuf
                             (head words') (tail words') help
           else return $ StatusResult $ Left "empty command"
      _ -> sendMessage config accounts cBuf cmd

uiRosterFilter configList buffer =
    case isShowOffline configList of
    True -> True
    False -> case buffer of
        (BufferRosterItem _ name ri) -> case (itemStatus ri) of
            StatusOffline _ -> False
            _ -> True
        _ -> True

-- | Filter buffers list (no offline users when configured)
getFilteredBuffersList account help configList = do
	buffers <- getBuffersList account help
	return $ filter (uiRosterFilter configList) buffers
-----------------------------------------------
-- connect to server
parseCommand config accounts cBuf "c" args _ | length args == 1 =
    getHashValue accounts (head args) >>=?
    connectAndAuth config accounts
parseCommand config accounts cBuf "c" args _ | null args =
    (return $ StatusResult $ getAcc cBuf) >>=?
    connectAndAuth config accounts

-- disconnect from server
parseCommand config accounts cBuf "d" args _ | length args == 1 =
    getHashValue accounts (head args) >>=?
    accDisconnect                     >>=?
    putAccount accounts
parseCommand config accounts cBuf "d" args _ | null args =
    (return $ StatusResult $ getAcc cBuf) >>=?
    accDisconnect                         >>=?
    putAccount accounts

-- join to groupchat
parseCommand config accounts cBuf "j" args _ | length args == 2 =
    getHashValue accounts (head args) >>=?
    accJoinGroupchat (last args ++ "@conference.jabber.ru")
parseCommand config accounts cBuf "j" args _ | length args == 1 =
    (return $ StatusResult $ getAcc cBuf) >>=?
    accJoinGroupchat (head args ++ "@conference.jabber.ru")

-- leave a groupchat
parseCommand config accounts cBuf "l" args _ | length args == 2 =
    getHashValue accounts (head args) >>=?
    accLeaveGroupchat (last args ++ "@conference.jabber.ru")
parseCommand config accounts cBuf "l" args _ | length args == 1 =
    (return $ StatusResult $ getAcc cBuf) >>=?
    accLeaveGroupchat (last args ++ "@conference.jabber.ru")
parseCommand config accounts cBuf "l" args _ | null args =
    (return $ StatusResult $ getMUC cBuf) >>=?
    \room -> accLeaveGroupchat room (fst . head . rights $ [getAcc cBuf])

-- set config value
parseCommand config accounts cBuf "set" args _ | length args == 2 =
    getHashValue config (head args) >>=?
    putConfigValue config (last args)

-- change presence information
parseCommand config accounts cBuf "online" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusOnline args

parseCommand config accounts cBuf "offline" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusOffline args

parseCommand config accounts cBuf "away" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusAway args

parseCommand config accounts cBuf "chat" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusChat args

parseCommand config accounts cBuf "dnd" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusDND args

parseCommand config accounts cBuf "xa" args _ =
    (return $ StatusResult $ getAcc cBuf) >>=?
    statusArgsConvert StatusXA args

parseCommand _ _ _ _ _ _ = return $ StatusResult $
                                     Left $ "can't parse command "++
                                            "(try print /help command)"


statusArgsConvert :: (Maybe String -> RosterItemStatus) -> [String] -> (String, Account) -> IO (StatusResult a)
statusArgsConvert status args | length args == 0 =
    accSetStatus (status Nothing) Nothing
statusArgsConvert status args | all isNumber $ head args =
    accSetStatus (status $ Just $ concat $ tail args) (Just $ read $ head args)
statusArgsConvert status args | otherwise =
    accSetStatus (status $ Just $ concat args) Nothing

-----------------------------------------------
sendMessage config accounts cBuf@(BufferGroupchat _ room _) msg =
    accSendGroupchat room msg (fst . head . rights $ [getAcc cBuf])
sendMessage config accounts cBuf@(BufferRosterItem _ _ item) msg =
    accSendChat (itemJid item) msg (fst . head . rights $ [getAcc cBuf])
sendMessage _ _ _ _ = return $ StatusResult $ Left $ "can't send message: "++
                                                     "not a chat"

-- | Helper.
a >>=? f = a >>= (\a' -> a' >? f)

StatusResult (Left e)       >? _ = return $ StatusResult $ Left e
StatusResult (Right (a, _)) >? f = f a

getAcc                  (BufferAccount n v)        = Right ((n, v), "")
getAcc (BufferChat      (BufferAccount n v) _ _  ) = Right ((n, v), "")
getAcc (BufferGroupchat (BufferAccount n v) _ _  ) = Right ((n, v), "")
getAcc (BufferSubchat   (BufferAccount n v) _ _ _) = Right ((n, v), "")
getAcc (BufferRosterItem (BufferAccount n v) _ _ ) = Right ((n, v), "")
getAcc _ = Left "not an account"

getMUC                  (BufferGroupchat _ name _)      = Right (name, "")
getMUC (BufferSubchat _ (BufferGroupchat _ name _) _ _) = Right (name, "")
getMUC _ = Left "not a groupchat"
